home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pcscheme / geneva / sources.exe / SOURCES / S / STANDARD.S < prev    next >
Encoding:
Text File  |  1993-10-24  |  15.0 KB  |  492 lines
  1. ; STANDARD.S
  2. ;************************************************************************
  3. ;*                                    *
  4. ;*        PC Scheme/Geneva 4.00 Scheme code            *
  5. ;*                                    *
  6. ;* (c) 1985-1988 by Texas Instruments, Inc. See COPYRIGHT.TXT        *
  7. ;* (c) 1992 by L. Bartholdi & M. Vuilleumier, University of Geneva    *
  8. ;*                                    *
  9. ;*----------------------------------------------------------------------*
  10. ;*                                    *
  11. ;*            Standard Scheme Routines            *
  12. ;*                                    *
  13. ;*----------------------------------------------------------------------*
  14. ;*                                    *
  15. ;* Created by: David Bartley        Date: 1985            *
  16. ;* Revision history:                            *
  17. ;* - 10 Feb 87:    BOOLEAN? and PROCEDURE? added for R^3 Report (tc)    *
  18. ;* - 1 Jun 87:    separated PSTD and PSTD2 for compiler-less system (tc)    *
  19. ;* - 9 Jun 87:    made list-tail a primitive operation (tc)        *
  20. ;* - 18 Jun 92:    Renaissance (Borland Compilers, ...)            *
  21. ;* - 23 Dec 92: Added R^4 support (apply f ...), (map f ...) (lb & mv)    *
  22. ;* - 9 Jan 93:  Added LIST? for R^4, and CIRCULAR-LIST?      (mv)    *
  23. ;*        Changed REVERSE! to recognize circular lists (mv)    *
  24. ;*                                    *
  25. ;*                    ``In nomine omnipotentii dei''    *
  26. ;************************************************************************
  27.  
  28. (define reverse!                    ; REVERSE!
  29.   (lambda (l)
  30.     (let ((ll (%reverse! l)))
  31.       (if (if (and (eq? ll l) (pair? (cdr ll)))    ; see CIRCULAR-LIST? below
  32.           #T
  33.           (not (null? (cdr l))))
  34.       (%error-invalid-operand 'REVERSE! (%reverse! ll))
  35.       ll))))
  36.  
  37. (begin
  38.   (define-integrable 1+                    ; 1+
  39.     (lambda (n) (+ n 1)))
  40.  
  41.   (define-integrable -1+                ; -1+
  42.     (lambda (n) (- n 1)))
  43.  
  44.   (define-integrable add1                ; ADD1
  45.     (lambda (n) (+ n 1)))
  46.  
  47.   (define-integrable apply                ; APPLY
  48.     (lambda (proc . args)
  49.       (define sgra (%reverse! (%append args '())))
  50.       (%apply proc (%append (%reverse! (cdr sgra)) (car sgra)))))
  51.  
  52.   (define-integrable caaaar (lambda (x) (caar (caar x)))) ; CAXXXR
  53.   (define-integrable caaadr (lambda (x) (caar (cadr x))))
  54.   (define-integrable caadar (lambda (x) (caar (cdar x))))
  55.   (define-integrable caaddr (lambda (x) (caar (cddr x))))
  56.   (define-integrable cadaar (lambda (x) (cadr (caar x))))
  57.   (define-integrable cadadr (lambda (x) (cadr (cadr x))))
  58.   (define-integrable caddar (lambda (x) (cadr (cdar x))))
  59. ; (define-integrable cadddr (lambda (x) (cadr (cddr x)))) ; opcode
  60.  
  61.   (define-integrable call/cc                ; CALL/CC
  62.     (lambda (exp)
  63.       (%call/cc exp)))
  64.  
  65.   (define-integrable call-with-current-continuation    ; CALL-w-c-c
  66.     (lambda (exp)
  67.       (%call/cc exp)))
  68.  
  69.   (define-integrable cdaaar (lambda (x) (cdar (caar x)))) ; CDXXXR
  70.   (define-integrable cdaadr (lambda (x) (cdar (cadr x))))
  71.   (define-integrable cdadar (lambda (x) (cdar (cdar x))))
  72.   (define-integrable cdaddr (lambda (x) (cdar (cddr x))))
  73.   (define-integrable cddaar (lambda (x) (cddr (caar x))))
  74.   (define-integrable cddadr (lambda (x) (cddr (cadr x))))
  75.   (define-integrable cdddar (lambda (x) (cddr (cdar x))))
  76.   (define-integrable cddddr (lambda (x) (cddr (cddr x))))
  77.  
  78.   (define-integrable empty-stream?            ; EMPTY-STREAM?
  79.     (lambda (x)
  80.       (eq? x the-empty-stream)))
  81.  
  82.   (define-integrable null?                ; NULL?
  83.     (lambda (obj)
  84.       (not obj)))
  85.  
  86.   (define-integrable pair-reverse! %reverse!)        ; PAIR-REVERSE!
  87.  
  88.   (define-integrable reverse                ; REVERSE
  89.     (lambda (l)
  90.       (reverse! (%append l '()))))
  91.  
  92.   (define-integrable sub1                ; SUB1
  93.     (lambda (n) (- n 1)))
  94.  
  95.   (define-integrable procedure?                ; PROCEDURE?
  96.     (lambda (obj)
  97.       (proc? obj)))
  98. )
  99.  
  100. (begin
  101.   (define ascii->symbol                    ; ASCII->SYMBOL
  102.     (lambda (n)
  103.       (string->symbol (make-string 1 (integer->char n)))))
  104.  
  105.   (define (copy x)                    ; COPY
  106.     (if (atom? x)
  107.     x
  108.     (cons (copy (car x))
  109.           (copy (cdr x)))))
  110.  
  111.   (define %delay                    ; %DELAY
  112.     (lambda (state)
  113.       (lambda ()
  114.     (when (closure? state)                ; not yet memoized?
  115.       (set! state (list (state))))
  116.     (car state))))
  117.  
  118.   (define delayed-object?                ; DELAYED-OBJECT?
  119.     (lambda (obj)
  120.       (and (vector? obj)
  121.        (positive? (vector-length obj))
  122.        (eq? (vector-ref obj 0) '#!DELAYED-OBJECT))))
  123.  
  124.   (define (delete! obj lst)                ; DELETE!
  125.     (letrec ((loop (lambda (obj a b z)
  126.              (cond ((atom? b) z)
  127.                ((equal? obj (car b))
  128.                 (set-cdr! a (cdr b))
  129.                 (loop obj a (cdr b) z))
  130.                (else (loop obj b (cdr b) z))))))
  131.       (cond ((atom? lst) '())
  132.         ((equal? obj (car lst)) (delete! obj (cdr lst)))
  133.         (else (loop obj lst (cdr lst) lst)))))
  134.  
  135.   (define (delq! obj lst)                ; DELQ!
  136.     (letrec ((loop (lambda (obj a b z)
  137.              (cond ((atom? b) z)
  138.                ((eq? obj (car b))
  139.                 (set-cdr! a (cdr b))
  140.                 (loop obj a (cdr b) z))
  141.                (else (loop obj b (cdr b) z))))))
  142.       (cond ((atom? lst) '())
  143.         ((eq? obj (car lst)) (delq! obj (cdr lst)))
  144.         (else (loop obj lst (cdr lst) lst)))))
  145.  
  146.   (define %execute                    ; %EXECUTE
  147.     (lambda (compiled-object)
  148.       (%%execute compiled-object)))            ; dangerous primitive!
  149.  
  150.   (define exit                        ; EXIT
  151.     (lambda args
  152.       (transcript-off)
  153.       (let ((code (if (null? (car args)) 0 (car args))))
  154.     (if (= code 0)
  155.         (with-output-to-file "history.ini"
  156.           (lambda () (print `(push-history ',(get-history))))))
  157.     (%halt code))
  158.       (reset)))
  159.  
  160.   (define explode                    ; EXPLODE
  161.     (lambda (obj)
  162.       (let ((x (if (symbol? obj)
  163.            (symbol->string obj)
  164.            obj)))
  165.     (cond ((string? x)
  166.            (do ((x x x)
  167.             (index 0 (add1 index))
  168.             (end (string-length x) end)
  169.             (result '()
  170.                 (cons (string->symbol (substring x index (+ index 1)))
  171.                   result)))
  172.            ((= index end) (%reverse! result))))
  173.           ((integer? x)
  174.            (do ((n (abs x) (quotient n 10))
  175.             (result '()
  176.                 (cons (ascii->symbol (+ (remainder n 10) 48))
  177.                   result)))
  178.            ((< n 10)
  179.             (let ((result (cons (ascii->symbol (+ n 48)) result)))
  180.               (if (negative? x) (cons '- result) result)))))
  181.           (else x)))))
  182.  
  183.   (define for-each                    ; FOR-EACH
  184.     (lambda (f l)
  185.       (do ((f f f)
  186.        (l l (cdr l)))
  187.       ((atom? l))
  188.       (f (car l)))))
  189.  
  190.   (define force                        ; FORCE
  191.     (lambda (obj)
  192.       (if (and (vector? obj)
  193.            (positive? (vector-length obj))
  194.            (eq? (vector-ref obj 0) '#!DELAYED-OBJECT))
  195.       ((vector-ref obj 1))
  196.       (%error-invalid-operand 'FORCE obj))))
  197.  
  198.   (define gc                        ; GC
  199.     (lambda args
  200. ;; do NOT define with define DEFINE-INTEGRABLE !!
  201. ;; do NOT hoist the call to %CLEAR-REGISTERS
  202.       (cond ((or (null? args)
  203.          (null? (car args)))
  204.          (%clear-registers)        ; unbind the VM registers
  205.          (%garbage-collect))    ; invoke the GC operation
  206.         (else
  207.           (%clear-registers)    ; unbind the VM registers
  208.           (%compact-memory)))))   ; GC and compaction both
  209.  
  210.   (define gcd                        ; GCD
  211.     (lambda args
  212.       (letrec ((gcd*
  213.          (lambda (args result)
  214.            (if (null? args)
  215.                result
  216.                (gcd* (cdr args)
  217.                  (gcd2 (abs (car args)) result)))))
  218.            (gcd2
  219.          (lambda (p q)
  220.            (if (zero? q)
  221.                p
  222.                (gcd2 q (remainder p q))))))
  223.     (gcd* args 0))))
  224.  
  225.   (define gensym                    ; GENSYM
  226.     (letrec
  227.       ((counter->string
  228.      (lambda (c n)
  229.        (cond ((positive? c)
  230.           (let ((string (counter->string (quotient c 10) (+ n 1))))
  231.             (string-set! string
  232.                  (- (string-length string) n 1)
  233.                  (string-ref "0123456789" (remainder c 10)))
  234.             string))
  235.          ((zero? n) "0")
  236.          (else (make-string n '()))))))
  237.       (let ((string "G")
  238.         (counter -1))
  239.     (lambda args
  240.       (set! counter (+ counter 1))
  241.       (when (not (null? args))
  242.         (let ((arg (car args)))
  243.           (cond ((integer? arg) (set! counter (abs arg)))
  244.             ((string? arg) (set! string arg))
  245.             ((symbol? arg) (set! string (symbol->string arg)))
  246.             (else '()))))
  247.       (string->uninterned-symbol
  248.         (string-append string (counter->string counter 0)))))))
  249.  
  250.   (define head                        ; HEAD
  251.     (lambda (stream)
  252.       (if (and (vector? stream)
  253.            (positive? (vector-length stream))
  254.            (eq? (vector-ref stream 0) '#!STREAM))
  255.       (vector-ref stream 1)
  256.       (%error-invalid-operand 'HEAD stream))))
  257.  
  258.   (define implode                    ; IMPLODE
  259.     (lambda (L)
  260.       (cond ((null? L) '||)
  261.         ((atom? L)
  262.          (%error-invalid-operand 'implode L))
  263.         (else
  264.           (let ((n (length L)))
  265.         (do ((L L (cdr L))
  266.              (string (make-string n '()) string)
  267.              (index 0 (add1 index)))
  268.             ((null? L) (string->symbol string))
  269.             (let* ((x (car L)))
  270.               (string-set!
  271.             string
  272.             index
  273.             (cond ((symbol? x) (string-ref (symbol->string x) 0))
  274.                   ((string? x) (string-ref x 0))
  275.                   ((char? x) x)
  276.                   ((integer? x) (integer->char x))
  277.                   (else (error "Invalid list element for IMPLODE" x)) )))))))))
  278.  
  279.   (define lcm                        ; LCM
  280.     (letrec ((lcm*
  281.            (lambda (args result)
  282.          (if (null? args)
  283.              result
  284.              (let ((a (car args)))
  285.                (if (zero? a)
  286.                0
  287.                (lcm* (cdr args)
  288.                  (quotient (abs (* a result))
  289.                        (gcd a result)))))))))
  290.       (lambda args
  291.     (lcm* args 1))))
  292.  
  293.   (define (list->stream L)                ; LIST->STREAM
  294.     (if (null? L)
  295.     the-empty-stream
  296.     (let ((heapL L))        ; control heap allocation of L
  297.       (cons-stream (car L)
  298.                (list->stream (cdr heapL))))))
  299.  
  300.   (define list->vector                    ; LIST->VECTOR
  301.     (lambda (L)                           
  302.       (let ((n (length L)))
  303.     (do ((v (make-vector n) v)
  304.          (i 0 (1+ i))
  305.          (L L (cdr L)))
  306.         ((null? L) v)
  307.         (vector-set! v i (car L))))))
  308.  
  309. (define list-ref                    ; LIST-REF
  310.   (lambda (x n)
  311.     (car (list-tail x n))))
  312.  
  313. ; List-tail was re-defined as a primitive on 6-9-87
  314. ;
  315. ; (define (list-tail x n)                ; LIST-TAIL
  316. ;   (if (positive? n)
  317. ;    (list-tail (cdr x)(sub1 n))
  318. ;    x))
  319.  
  320. (define (map proc . l)                    ; MAP
  321.   (do ((proc proc proc)
  322.        (l l (do ((l l (cdr l))
  323.                  (n '() (cons (cdar l) n)))
  324.                 ((atom? l) (%reverse! n))))
  325.        (a '() (cons (apply proc (do ((l l (cdr l))
  326.                      (n '() (cons (caar l) n)))
  327.                     ((atom? l) (%reverse! n))))
  328.                    a)))
  329.       ((atom? (car l)) (%reverse! a))))
  330.  
  331. (define mapc                        ; MAPC
  332.   for-each)
  333.  
  334. (define mapcar                        ; MAPCAR
  335.   map)
  336.  
  337. (define property                    ; PROPERTY
  338.   (lambda (symbol . args)
  339.     (cond ((null? args) (proplist symbol))
  340.       ((null? (cadr args)) (getprop symbol (car args)))
  341.       ((eq? (cadr args) '#!UNDEFINED) (remprop symbol (car args)))
  342.       ((null? (caddr args)) (putprop symbol (cadr args) (car args)))
  343.       (else (%error-invalid-operand 'property args)))))
  344.  
  345. (define (random n)                    ; RANDOM
  346.   (let* ((wordsize 32768)
  347.          (prec (do ((i 0 (1+ i))
  348.                     (p 1 (* p wordsize)))
  349.                    ((>= p n) (cons p i))))
  350.          (newrandom (named-lambda (newrandom i) (if (= i 0) 0 (+ (* wordsize (newrandom (-1+ i)))
  351.                                                  (%random)))))
  352.          (bound (* n (quotient (car prec) n))))
  353.     (if (<= n 0)
  354.     (%error-invalid-operand 'random n))
  355.     (do ((try (newrandom (cdr prec)) (newrandom (cdr prec))))
  356.         ((< try bound) (remainder try n)))))
  357.  
  358. (define (randomize . seed)                ; RANDOMIZE
  359.     (%esc 20 (if (integer? (car seed)) (car seed) -1)))
  360.  
  361. (define clock                        ; CLOCK
  362.   (lambda ()
  363.     (%esc 43)))
  364. (define clock-tick
  365.   (/ #x10000 (* 60 60)))
  366.  
  367. (define time                        ; TIME services
  368.   (let ((locale '()))
  369.     (lambda (message . args)
  370.       (let* ((locals '())
  371.          (complete (named-lambda (complete source supply length)
  372.              (if (= length 0)
  373.                  '()
  374.                  (let ((new (car (if (null? source) supply source))))
  375.                    (cons (apply-if (assq new (apply append locals))
  376.                        (lambda (e) (cdr e))
  377.                        new)
  378.                      (complete (cdr source) (cdr supply) (-1+ length)))))))
  379.          (getunix (lambda args
  380.             (cond ((null? args) (%esc 44))
  381.                   ((integer? (car args)) (car args))
  382.                   ((list? (car args))
  383.                    (let ((now (%esc 45 0 (%esc 44 0))))
  384.                  (apply %esc 46 0 (complete (car args) now 6))))
  385.                   (else (%error-invalid-operand 'TIME args)))))
  386.          (set-at! (lambda (n l table)
  387.                (let ((at (list-tail l n)))
  388.                  (apply-if (assq (car at)
  389.                          (map (lambda (pair)
  390.                             (cons (cdr pair) (car pair)))
  391.                           table))
  392.                    (lambda (e) (set-car! at (cdr e)))))))
  393.          (dotime (lambda (mode . args)
  394.                (let ((local (%esc 45 mode (getunix args))))
  395.              (set-at! 4 local (car locals))
  396.              (set-at! 6 local (cadr locals))
  397.              (set-at! 8 local (caddr locals))
  398.              local)))
  399.          (jobs `((UNIX . ,(lambda args (apply getunix args)))
  400.              (LOCAL . ,(lambda args (apply dotime 0 args)))
  401.              (GM . ,(lambda args (apply dotime 1 args)))
  402.              (COUNTRY . ,(lambda args
  403.                    (apply-if (assq (car args) locale)
  404.                      (lambda (e)
  405.                        (set! locale (delete! e locale))))
  406.                    (set! locale (cons args locale))))
  407.             )))
  408.     (apply-if (assq (car args) locale)
  409.       (lambda (e)
  410.         (set! locals (cdr e))
  411.         (set! args (cdr args))))
  412.     (apply-if (assq message jobs)
  413.       (lambda (job) (apply (cdr job) args))
  414.       (%error-invalid-operand 'TIME message))))))
  415.  
  416. (time 'COUNTRY 'ENGLISH
  417.       '((january . 0) (february . 1) (march . 2) (april . 3)
  418.     (may . 4) (june . 5) (july . 6) (august . 7)
  419.     (september . 8) (october . 9) (november . 10) (december . 11))
  420.       '((sunday . 0) (monday . 1) (tuesday . 2) (wednesday . 3)
  421.     (thursday . 4) (friday . 5) (saturday . 6))
  422.       '((dst-on . 0) (dst-off . 1))
  423. )
  424. (time 'COUNTRY 'FRENCH
  425.       '((janvier . 0) (fevrier . 1) (mars . 2) (avril . 3)
  426.     (mai . 4) (juin . 5) (juillet . 6) (aout . 7)
  427.     (septembre . 8) (octobre . 9) (novembre . 10) (decembre . 11))
  428.       '((dimanche . 0) (lundi . 1) (mardi . 2) (mercredi . 3)
  429.     (jeudi . 4) (vendredi . 5) (samedi . 6))
  430.       '((sans-changement . 0) (changement . 1))
  431. )
  432.  
  433. (define stream?                        ; STREAM?
  434.   (lambda (obj)
  435.     (or (eq? obj the-empty-stream)
  436.     (and (vector? obj)
  437.          (positive? (vector-length obj))
  438.          (eq? (vector-ref obj 0) '#!STREAM)))))
  439.  
  440. (define (stream->list stream)                ; STREAM->LIST
  441.   (if (empty-stream? stream)
  442.       '()
  443.       (cons (head stream)
  444.         (stream->list (tail stream)))))
  445.  
  446. (define symbol->ascii                    ; SYMBOL->ASCII
  447.   (lambda (s)
  448.     (char->integer (string-ref (symbol->string s) 0))))
  449.  
  450. (define tail                        ; TAIL
  451.   (lambda (stream)
  452.     (if (and (vector? stream)
  453.          (positive? (vector-length stream))
  454.          (eq? (vector-ref stream 0) '#!STREAM))
  455.     ((vector-ref stream 2))
  456.     (%error-invalid-operand 'TAIL stream))))
  457.  
  458. (define thaw                        ; THAW
  459.   (lambda (thunk)
  460.     (thunk)))
  461.  
  462. (define vector->list                    ; VECTOR->LIST
  463.   (lambda (v)
  464.     (do ((n (vector-length v) n)
  465.      (i 0 (1+ i))
  466.      (L '() (cons (vector-ref v i) L)))
  467.     ((>= i n)
  468.      (%reverse! L)))))
  469.  
  470. (define boolean?                    ; BOOLEAN?
  471.    (lambda (obj)
  472.       (or (eq? obj #T) (null? obj) #F)))
  473.  
  474. (define circular-list?                    ; CIRCULAR-LIST?
  475.   (lambda (l)
  476.     (if (pair? l)
  477.       (let* ((ll (%reverse! l))        ; when loop exists, reverse loop only
  478.              (result (and (eq? ll l)    ; ...and first cell stay unchanged
  479.                   (pair? (cdr ll)))))
  480.         (%reverse! ll)
  481.         result)
  482.       #F)))
  483.  
  484. (define list?                        ; LIST?
  485.   (lambda (l)                ; R4RS definition:
  486.     (or (null? l)
  487.         (if (or (atom? l) (circular-list? l))    ; end with a NULL
  488.         #F
  489.         (null? (cdr (last-pair l)))))))
  490. )
  491.  
  492.